home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / error.c < prev    next >
C/C++ Source or Header  |  1993-07-16  |  16KB  |  590 lines
  1. /* ******************************************************************** */
  2. /*  error.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Error and Signal handling                                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: error.c,v 2.1 93/01/17 17:25:21 pab Exp $
  9.  *
  10.  * $Log:    error.c,v $
  11.  * Revision 2.1  93/01/17  17:25:21  pab
  12.  * 17 Jan 1993 The next generation...
  13.  * 
  14.  * Revision 1.14  1992/11/25  17:20:33  pab
  15.  * error handlers changed to be user-level
  16.  *
  17.  * Revision 1.13  1992/07/22  15:35:05  pab
  18.  * corrected fn_signal
  19.  *
  20.  * Revision 1.12  1992/06/27  05:04:42  kjp
  21.  * False alarm but added this RCS header so it wasn't a complete loss...
  22.  *
  23.  *
  24.  */
  25.  
  26. /*
  27.  * Change Log:
  28.  *   Version 1, April 1989
  29.  *    Added names of the defined conditions - JPff
  30.  *   Version 2, May 1989
  31.  *    Amalgamated with section condition.c for sanity
  32.  *   Version 3, May 1989
  33.  *      Updated for new ideas on handlers/restarts - RJB
  34.  *      Integrated conditions into the object system - KJP
  35.  *   Version 4, June 1990
  36.  *      Rewrote handlers and signals correctly - KJP
  37.  *        - with-handler special 
  38.  *        - generally rearranged 
  39.  */
  40.  
  41. #include <stdio.h>
  42. #include <string.h>
  43. #include "defs.h"
  44. #include "structs.h"
  45. #include "funcalls.h"
  46.  
  47. #include "global.h"
  48. #include "error.h"
  49.  
  50. #include "bootstrap.h"
  51. #include "slots.h"
  52. #include "class.h"
  53.  
  54. #include "symboot.h"
  55. #include "modules.h"
  56. #include "specials.h"
  57. #include "modboot.h"
  58. #include "ngenerics.h"
  59. #include "calls.h"
  60. #include "streams.h"
  61. #include "state.h"
  62.  
  63. #define N_SLOTS_IN_CONDITION 2
  64. /* The error system classes... */
  65.  
  66. LispObject Condition_Class; 
  67. LispObject Default_Condition;
  68.  
  69. /* Array for pre-defind conditions... */
  70.  
  71. LispObject defined_conditions; /* a vector of junk */
  72.  
  73. extern LispObject unbound;
  74.  
  75. /*
  76.  * Conditions...
  77.  * Includes generation and defined slot access... 
  78.  */
  79.  
  80. /* Predicate... */
  81.  
  82. EUFUN_1( Fn_conditionp, form)
  83. {
  84.   return (is_condition(form) ? lisptrue : nil);
  85. }
  86. EUFUN_CLOSE
  87.  
  88. /* Generator... */
  89.  
  90. EUFUN_2( Fn_make_condition, class, initlist)
  91. {
  92.   LispObject ans;
  93.   
  94.   EUCALLSET_2(ans, Fn_subclassp, classof(class),Condition_Class);
  95.   if (ans==nil)
  96.     CallError(stackbase, "make-condition: non condition class",
  97.           ARG_0(stackbase),NONCONTINUABLE);
  98.  
  99.   return(Gf_make_instance(stackbase));
  100.  
  101. }
  102. EUFUN_CLOSE
  103.  
  104. /* 
  105.  * Signals and Handlers...
  106.  */
  107.  
  108. /* Heap collapse... */
  109.  
  110. void signal_heap_failure(LispObject *stacktop, int type)
  111. {
  112.   extern LispObject Fn_abort_thread(LispObject*);
  113.   extern LispObject interpreter_thread;
  114.   extern LispObject read_eval_print_continue;
  115.   /* Cannot allocate in this function... */
  116.   print_string(stacktop,lisptrue,
  117.       "\nTrapping heap exhaustion condition\n\n");
  118.   
  119. #ifndef MACHINE_ANY
  120.  
  121.   if (CURRENT_THREAD() == CAR(interpreter_thread)) {
  122.     print_string(stacktop,lisptrue, 
  123.         "Calculation abandoned - returning to top level...\n\n");
  124.     call_continue(stacktop,CAR(read_eval_print_continue),lisptrue);
  125.   }
  126.  
  127.   print_string(stacktop,lisptrue,
  128.            "Thread aborting - wait for other failures...\n\n");
  129.   (void) Fn_abort_thread(stacktop);
  130.  
  131. #else
  132.  
  133.   print_string(stacktop,lisptrue,
  134.       "Calculation abandoned - returning to top level...\n\n");
  135.   call_continue(stacktop,CAR(read_eval_print_continue),lisptrue);
  136.  
  137. #endif
  138. }
  139.  
  140. /* Prompt string... */
  141.  
  142. #define MAX_PROMPT_LENGTH (1024)
  143. char current_prompt_string[MAX_PROMPT_LENGTH];
  144.   
  145. /* Default signal handling... */
  146.  
  147. static LispObject sym_pling_backtrace;
  148. static LispObject sym_pling_b;
  149. static LispObject sym_pling_quickie;
  150. static LispObject sym_pling_q;
  151. LispObject sym_pling_exit; 
  152. LispObject sym_pling_root;
  153.  
  154. extern LispObject Gf_generic_write(LispObject*);
  155.  
  156. void condition_handler(LispObject *stackbase, LispObject cond,LispObject cont)
  157. {
  158.   extern 
  159.     SYSTEM_THREAD_SPECIFIC_DECLARATION(int,system_scheduler_number);
  160.   extern 
  161.     LispObject Gf_generic_prin(LispObject*);
  162.   extern
  163.     void module_eval_backtrace(LispObject *);
  164.   extern
  165.     void quickie_module_eval_backtrace(LispObject *);
  166.   extern
  167.     LispObject get_history_form(LispObject);
  168.   extern
  169.     void put_history_form(LispObject*, LispObject);
  170.   extern
  171.     int get_history_count(void);
  172.  
  173.   LispObject *stacktop = stackbase;
  174.   LispObject form,value;
  175.  
  176.   while (TRUE) {
  177.     sprintf(current_prompt_string,"eulisp-handler:%x:%s!%d> ",
  178.         SYSTEM_THREAD_SPECIFIC_VALUE(system_scheduler_number),
  179.         stringof(SYSTEM_GLOBAL_VALUE(current_interactive_module)
  180.              ->I_MODULE.name->SYMBOL.pname),
  181.         get_history_count());
  182.     
  183. #ifndef GNUREADLINE
  184.     print_string(stacktop,StdOut(),current_prompt_string);
  185.     generic_apply_1(stacktop,generic_flush,StdOut());
  186. #endif
  187.     
  188.     EUCALLSET_1(form, Fn_read, StdIn());
  189.     form = get_history_form(form);
  190.     put_history_form(stacktop, form);
  191.  
  192.     if (form == sym_pling_exit || form == q_eof) 
  193.       {
  194.     print_string(stacktop,StdOut(),"\n");
  195.     return;
  196.       }
  197.     if (form == sym_pling_root)
  198.       {
  199.     SYSTEM_GLOBAL_VALUE(current_interactive_module) =
  200.       get_module(stacktop,sym_root);
  201.     value = nil;
  202.       } 
  203.     else if (form == sym_pling_backtrace || form == sym_pling_b)
  204.       {
  205.     module_eval_backtrace(stacktop);
  206.     value = nil;
  207.       }
  208.     else if (form == sym_pling_quickie || form == sym_pling_q) 
  209.       {
  210.     quickie_module_eval_backtrace(stacktop);
  211.     value = nil;
  212.       }
  213.     else
  214.       EUCALLSET_2(value,process_top_level_form,
  215.           SYSTEM_GLOBAL_VALUE(current_interactive_module),
  216.           form);
  217.     
  218.     sprintf(current_prompt_string,"eulisp-handler:%x:%s!%d< ",
  219.         SYSTEM_THREAD_SPECIFIC_VALUE(system_scheduler_number),
  220.         stringof(SYSTEM_GLOBAL_VALUE(current_interactive_module)
  221.              ->I_MODULE.name->SYMBOL.pname),
  222.         get_history_count()-1);
  223.     print_string(stacktop,StdOut(),current_prompt_string);
  224.  
  225.     generic_apply_2(stacktop,generic_write,value,StdOut());
  226.     
  227.     print_string(stacktop,StdOut(),"\n\n");
  228.   }
  229. }
  230.  
  231. LispObject function_bootstrap_handler;
  232. EUFUN_2( Fn_bootstrap_handler, cond, cont)
  233. {
  234.   LispObject slots;
  235.  
  236.   /* Check for dumb errors... */
  237.  
  238.   if (!is_condition(cond))
  239.     CallError(stackbase,
  240.           "Default Handler not given a condition",cond,NONCONTINUABLE);
  241.  
  242.   if (!is_continue(cont) && cont != nil)
  243.     CallError(stackbase,"Invalid continuation in default handler",cont,
  244.           NONCONTINUABLE);
  245.  
  246.   /* Now, display error message... */
  247.  
  248.   fprintf(stderr,"\nCompiled Elvira initialisation code error!!!\n"); 
  249.  
  250.   fprintf(stderr,"\nTrapping unhandled "); 
  251.   if (cont == nil)
  252.     fprintf(stderr,"non-continuable \"");
  253.   else
  254.     fprintf(stderr,"continuable \"");
  255.  
  256.   fprintf(stderr,"error\"");
  257.   fprintf(stderr,"Check for initcode module --- It is needed\n");
  258.   system_lisp_exit(1);
  259.   
  260.   return(nil);            /* dummy return */
  261. }
  262. EUFUN_CLOSE
  263.  
  264. LispObject function_default_handler;
  265.  
  266. LispObject Cb_Error_Printout;
  267.  
  268. static EUFUN_1(Fn_set_print_error_callback,val)
  269. {
  270.   CAR(Cb_Error_Printout)=val;
  271.   return nil;
  272. }
  273. EUFUN_CLOSE
  274.  
  275.  
  276. EUFUN_2( Fn_default_handler, cond, cont)
  277. {
  278.   LispObject slots;
  279.  
  280.   /* Check for dumb errors... */
  281.  
  282.   if (!is_condition(cond))
  283.     CallError(stackbase,
  284.           "Default Handler not given a condition",cond,NONCONTINUABLE);
  285.  
  286.   if (!is_continue(cont) && cont != nil)
  287.     CallError(stackbase,"Invalid continuation in default handler",cont,
  288.           NONCONTINUABLE);
  289.  
  290.   /* Now, display error message... */
  291.  
  292.   /* Should check if it's a heap error... */
  293.  
  294.   if (CAR(Cb_Error_Printout)==nil)
  295.     {
  296.       fprintf(stderr,"Error called with no handler.\n");
  297.       fprintf(stderr," Error message: %s.",stringof(condition_message(cond)));
  298.     }
  299.   else
  300.     {
  301.       LispObject lst;
  302.       lst=EUCALL_2(Fn_cons,cont,nil);
  303.       lst=EUCALL_2(Fn_cons,ARG_0(stackbase),lst);
  304.       (void) EUCALL_2(Fn_apply,CAR(Cb_Error_Printout),lst);
  305.     }
  306.  
  307.   {
  308.     extern void module_eval_backtrace(LispObject *);
  309.     extern LispObject Fn_abort_thread(LispObject *);
  310.     extern LispObject read_eval_print_continue;
  311.     extern LispObject interpreter_thread;
  312.     extern void call_continuation(LispObject*,LispObject,LispObject);
  313.  
  314.     /* Go for auto-backtrace on weird threads */
  315.  
  316.     cond = ARG_0(stackbase);
  317.     cont = ARG_1(stackbase);
  318.     if (CURRENT_THREAD() == CAR(interpreter_thread)) {
  319.       condition_handler(stacktop,cond,cont);
  320.       call_continuation(stacktop,CAR(read_eval_print_continue),nil);
  321.     }
  322. #ifndef MACHINE_ANY
  323.     
  324.     print_string(stacktop,StdErr(),"ABORTING THREAD: ");
  325.     generic_apply_2(stacktop,generic_write,CURRENT_THREAD(),StdErr());
  326.  
  327.     print_string(stacktop,StdErr(),"\n\nBacktrace follows...\n");
  328.     module_eval_backtrace(stacktop);
  329.     print_string(stacktop,StdErr(),"Thread aborted.\n\n");
  330.     (void) Fn_abort_thread(stacktop);
  331.  
  332. #endif
  333.  
  334.   }
  335.  
  336.   return(nil);            /* dummy return */
  337. }
  338. EUFUN_CLOSE
  339.  
  340. /* User signal function... */
  341.  
  342. EUFUN_2( Fn_signal, cond, cont)
  343. {
  344.   LispObject stack;
  345.  
  346.   if (cont != nil && !is_continue(cont))
  347.     CallError(stackbase,"signal: non continuation",cont,NONCONTINUABLE);
  348.  
  349.   if (!is_condition(cond))
  350.     CallError(stackbase,"signal: not a condition",cond,NONCONTINUABLE);
  351.  
  352.   /* OK, grab a handler and do the business... */
  353.  
  354.   /* Here be strangeness - handlers are executed in the handler environment
  355.      of their establishment => (I think) just decrementing the handler stack
  356.      as we run along - continuations will re-instate, but keep a copy for
  357.      GC safety... */
  358.  
  359.   stack = HANDLER_STACK();
  360.  
  361.   STACK_TMP(stack);
  362.   
  363.   while (is_cons(HANDLER_STACK())) {
  364.     LispObject handle;
  365.  
  366.     handle = CAR(HANDLER_STACK()); 
  367.     HANDLER_STACK() = CDR(HANDLER_STACK());
  368.  
  369.     /* Need this 'cos apply allocates... */
  370.     
  371.     if (handle == function_default_handler)
  372.       EUCALL_2(Fn_default_handler,cond,cont);
  373.     else
  374.       EUCALL_3(apply2,handle,cond,cont);
  375.     cond = ARG_0(stackbase);
  376.     cont = ARG_1(stackbase);
  377.  
  378.     /* Back here means try again... */
  379.   }
  380.  
  381.   /* Ack! No handler accepted!! */
  382.   EUCALL_2(Fn_default_handler,cond,cont);
  383. #ifdef old /* Mon Jul  6 10:56:55 1992 */
  384. /**/
  385. /**/  UNSTACK_TMP(stack);
  386. /**/
  387. /**/  HANDLER_STACK() = stack;
  388. #endif /* old Mon Jul  6 10:56:55 1992 */
  389.  
  390.   return(cond);
  391. }
  392. EUFUN_CLOSE
  393.  
  394. /*
  395.  * Internally used error handling and signalling...
  396.  */
  397.  
  398. /* Signal condition i with message and one value... */
  399.  
  400. /* Emergency heap condition... */
  401.  
  402. LispObject condition_heap_exhausted;
  403.  
  404. void signal_message(LispObject *stackbase, int i,char *message,LispObject val)
  405. {
  406.   LispObject cond_class;
  407.   LispObject cond;
  408.   LispObject *stacktop = stackbase;
  409.   STACK_TMP(val);
  410.  
  411.   /* Special case if out of heap... */
  412.  
  413.   if (i == HEAP_EXHAUSTED) {
  414.     cond = condition_heap_exhausted;
  415.     fprintf(stderr,"Heap wimped out!! Rats.\n");
  416.     system_lisp_exit(1);
  417.   }
  418.   else {
  419.     cond_class = vref(defined_conditions,i);
  420.     cond = (LispObject) allocate_instance(stacktop,cond_class);
  421.   }
  422.   STACK_TMP(cond);
  423.   condition_message(cond) = 
  424.     (LispObject) allocate_string(stacktop,message,strlen(message));
  425.   UNSTACK_TMP(cond);
  426.   UNSTACK_TMP(val);
  427.   condition_error_value(cond) = val;
  428.  
  429.   STACK_TMP(cond);
  430.   EUCALL_2(Fn_signal,cond,nil);
  431.   UNSTACK_TMP(cond);
  432.  
  433.   /* Returned => call default... */
  434.  
  435.   EUCALL_2(Fn_default_handler,cond,nil);
  436.  
  437.   /* Returned means deep trouble... */
  438.  
  439.   fprintf(stderr,"INTERNAL ERROR: signal returned on internal call\n");
  440.   fprintf(stderr,"Message was: '%s'\n",message); fflush(stderr);
  441.  
  442.   system_lisp_exit(1);
  443. }
  444.  
  445.  
  446. LispObject CallError(LispObject *stackbase, char *format,LispObject x,int type)
  447. {
  448.   IGNORE(type);
  449.   if (StdErr()==lisptrue)
  450.     {    
  451.       fprintf(stderr,"system error: %s %s\n",format,
  452.           is_symbol(x) ? stringof(x->SYMBOL.pname) :"");
  453.     
  454.       system_lisp_exit(1);
  455.     }
  456.   signal_message(stackbase, INTERNAL_ERROR,format,x);
  457.   return(nil);
  458. }
  459.  
  460. EUFUN_3( Fn_cerror, message, cond, args)
  461. {
  462.   LispObject cont,val;
  463.  
  464.   cont = (LispObject) allocate_continue(stackbase);
  465.  
  466.   if (set_continue(stacktop,cont)) return(cont->CONTINUE.value);
  467.  
  468.   STACK_TMP(cont);
  469.   message = ARG_0(stackbase);
  470.   args = ARG_2(stackbase);
  471.   EUCALLSET_2(message, Fn_cons, message, args);
  472.   EUCALLSET_2(message, Fn_cons, sym_message, message);
  473.   cond = ARG_1(stackbase);
  474.   EUCALLSET_2(message, Fn_make_condition, cond, message);
  475.   UNSTACK_TMP(cont);
  476.   EUCALLSET_2(val, Fn_signal, message, cont);
  477.   call_continue(stacktop,cont,val);
  478.   return(val);
  479. }
  480. EUFUN_CLOSE
  481.  
  482. EUFUN_3( Fn_error, message, cond, args)
  483. {
  484.   LispObject val;
  485.  
  486.   EUCALLSET_2(message, Fn_cons, message, args);
  487.   EUCALLSET_2(message, Fn_cons, sym_message, message);
  488.   cond = ARG_1(stackbase);
  489.   EUCALLSET_2(message, Fn_make_condition, cond, message);
  490.   EUCALLSET_2(val, Fn_signal, message, nil);
  491.   return(val);
  492. }
  493. EUFUN_CLOSE
  494.  
  495. /* *************************************************************** */
  496. /* Initialisation of this section                                  */
  497. /* *************************************************************** */
  498.  
  499. #define ERRORS_ENTRIES 11
  500. MODULE Module_errors;
  501. LispObject Module_errors_values[ERRORS_ENTRIES];
  502.  
  503. void initialise_error(LispObject *stacktop)
  504. {
  505.  
  506.   static char* inits[] = {
  507.     "<Internal-Error>",        /* INTERNAL_ERROR */
  508.     "<heap-exhausted>",        /* HEAP_EXHAUSTED */
  509.     "<clock-tick>",        /* CLOCK_TICK */
  510.     0
  511.   };
  512.   int i;
  513.  
  514.   /* Initialise condition metaclass */
  515.  
  516.   Condition_Class = (LispObject) allocate_class(stacktop,NULL);
  517.   set_class_size(stacktop,Condition_Class,Standard_Class,0);
  518.   add_root(&Condition_Class);
  519.   
  520.   Default_Condition = (LispObject) allocate_class(stacktop,NULL);
  521.   add_root(&Default_Condition);
  522.   set_class_size(stacktop,Default_Condition,Object, N_SLOTS_IN_CONDITION);
  523.  
  524.   defined_conditions=allocate_vector(stacktop,99);
  525.   add_root(&defined_conditions);
  526.  
  527.   for (i=0; inits[i]; i++) {
  528.     LispObject cond_class;
  529.     
  530.     cond_class=allocate_class(stacktop,Condition_Class);
  531.     vref(defined_conditions,i) = cond_class;
  532.     set_class_size(stacktop,vref(defined_conditions,i),Default_Condition,0);
  533.   }
  534.  
  535.   /* Rig heap failure condition... */
  536.  
  537.   condition_heap_exhausted = 
  538.     (LispObject) 
  539.       allocate_instance(stacktop,
  540.              vref(defined_conditions,HEAP_EXHAUSTED));
  541.  
  542.   add_root(&condition_heap_exhausted);
  543.   sym_pling_backtrace = get_symbol(stacktop,"!backtrace");
  544.   add_root(&sym_pling_backtrace);
  545.   sym_pling_b = get_symbol(stacktop,"!b");
  546.   add_root(&sym_pling_b);
  547.   sym_pling_quickie = get_symbol(stacktop,"!quickie");
  548.   add_root(&sym_pling_quickie);
  549.   sym_pling_q = get_symbol(stacktop,"!q");
  550.   add_root(&sym_pling_q);
  551.   sym_pling_exit = get_symbol(stacktop,"!exit");
  552.   add_root(&sym_pling_exit);
  553.   sym_pling_root = get_symbol(stacktop,"!root");
  554.   add_root(&sym_pling_root);
  555.  
  556.   open_module(stacktop,
  557.           &Module_errors,
  558.           Module_errors_values,
  559.           "errors",
  560.           ERRORS_ENTRIES);
  561.   
  562.   make_module_entry(stacktop,"<condition-class>",Condition_Class);
  563.   make_module_entry(stacktop,"<condition>",Default_Condition);
  564.   
  565.   for (i=0; inits[i]; i++)
  566.     make_module_entry(stacktop,inits[i],vref(defined_conditions,i));
  567.        
  568.   (void) make_module_function(stacktop,"conditionp",Fn_conditionp,1);
  569.  
  570.   (void) make_module_function(stacktop,"make-condition",Fn_make_condition,-2);
  571.  
  572.   (void) make_module_function(stacktop,"internal-signal",Fn_signal,2);
  573.  
  574.   function_bootstrap_handler
  575.     = make_unexported_module_function(stacktop,"bootstrap-handler",
  576.                       Fn_bootstrap_handler,2);
  577.   add_root(&function_bootstrap_handler);
  578.   function_default_handler 
  579.     = make_unexported_module_function(stacktop,"default-handler",Fn_default_handler,2);
  580.   add_root(&function_default_handler);
  581.  
  582.   Cb_Error_Printout=EUCALL_2(Fn_cons,nil,nil);
  583.   add_root(&Cb_Error_Printout);
  584.   (void) make_module_function(stacktop,"set-print-error-callback",Fn_set_print_error_callback,1);
  585.  
  586.  
  587.   close_module();
  588. }
  589.  
  590.